PC Users 1998 March/Pc Users extra 6.iso/pshare95/prog/formula1/vcform1.z/frmMain.frm

Visual Basic Form | 1997-10-20 | 16.0 KB | 468 lines

VERSION 5.00
Object = "{13E51000-A52B-11D0-86DA-00608CB9FBFB}#5.0#0"; "VCF15.OCX"
Begin VB.Form frmMain
   Caption         =   "Smallville Genealogical Society"
   ClientHeight    =   6060
   ClientLeft      =   1650
   ClientTop       =   1935
   ClientWidth     =   9525
   LinkTopic       =   "Form1"
   ScaleHeight     =   6060
   ScaleWidth      =   9525
   Begin VB.CommandButton cmdNew
      Caption         =   ">*"
      BeginProperty Font
         Name            =   "Arial"
         Size            =   14.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   4920
      Style           =   1  'Graphical
      TabIndex        =   6
      Top             =   5520
      Width           =   495
   End
   Begin VB.CommandButton cmdLast
      Caption         =   ">I"
      BeginProperty Font
         Name            =   "Arial"
         Size            =   14.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   4440
      Style           =   1  'Graphical
      TabIndex        =   5
      Top             =   5520
      Width           =   495
   End
   Begin VB.CommandButton cmdNext
      Caption         =   ">"
      BeginProperty Font
         Name            =   "Arial"
         Size            =   14.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   3960
      Style           =   1  'Graphical
      TabIndex        =   4
      Top             =   5520
      Width           =   495
   End
   Begin VB.CommandButton cmdBack
      Caption         =   "<"
      BeginProperty Font
         Name            =   "Arial"
         Size            =   14.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   2400
      Style           =   1  'Graphical
      TabIndex        =   3
      Top             =   5520
      Width           =   495
   End
   Begin VB.CommandButton btnFirst
      Caption         =   "I<"
      BeginProperty Font
         Name            =   "Arial"
         Size            =   14.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   1920
      Style           =   1  'Graphical
      TabIndex        =   2
      Top             =   5520
      Width           =   495
   End
   Begin VCF150Ctl.F1Book F1Book1
      Height          =   4455
      Left            =   240
      TabIndex        =   1
      Top             =   960
      Width           =   9135
      _ExtentX        =   16113
      _ExtentY        =   7858
      _0              =   $"frmMain.frx":0000
      _1              =   $"frmMain.frx":0405
      _2              =   $"frmMain.frx":080A
      _3              =   $"frmMain.frx":0C0F
      _4              =   $"frmMain.frx":1014
      _5              =   $"frmMain.frx":1419
      _6              =   $"frmMain.frx":181E
      _7              =   $"frmMain.frx":1C23
      _8              =   $"frmMain.frx":2028
      _9              =   $"frmMain.frx":242D
      _count          =   10
      _ver            =   1
   End
   Begin VB.Label Label3
      Caption         =   "Record"
      BeginProperty Font
         Name            =   "Tahoma"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000002&
      Height          =   255
      Left            =   960
      TabIndex        =   8
      Top             =   5520
      Width           =   855
   End
   Begin VB.Label lblRecordNo
      Alignment       =   2  'Center
      BackColor       =   &H8000000E&
      BorderStyle     =   1  'Fixed Single
      Caption         =   "1 of 15"
      BeginProperty Font
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000002&
      Height          =   375
      Left            =   2880
      TabIndex        =   7
      Top             =   5520
      Width           =   1095
   End
   Begin VB.Label Label1
      Alignment       =   2  'Center
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Smallville Genealogical Society"
      BeginProperty Font
         Name            =   "Tahoma"
         Size            =   24
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000002&
      Height          =   735
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   9135
   End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim NewRecord As Boolean
Dim CurrentRow As Integer
Dim Formatting As Boolean
Private Sub btnFirst_Click()
    With F1Book1
        .SetActiveCell 1, 1
        .ShowActiveCell
        .SetFocus
    End With
End Sub
Private Sub cmdBack_Click()
    With F1Book1
        .SetActiveCell (F1Book1.Row - 1), 1
        .ShowActiveCell
        .SetFocus
    End With
End Sub
Private Sub cmdLast_Click()
     With F1Book1
        .SetActiveCell .MaxRow, 1
        .ShowActiveCell
        .SetFocus
    End With
End Sub
Private Sub cmdNew_Click()
    With F1Book1
        .MaxRow = .MaxRow + 1
        .SetActiveCell .MaxRow, 1
        .ShowActiveCell
        .SetFocus

        NewRecord = True
        .NumberRC(.MaxRow, 1) = .NumberRC(.MaxRow - 1, 1) + 1
        .TextRC(.MaxRow, 4) = "Male"
    End With
End Sub
Private Sub cmdNext_Click()
    With F1Book1
        .SetActiveCell (.Row + 1), 1
        .ShowActiveCell
        .SetFocus
    End With
End Sub
Private Sub F1Book1_KeyDown(KeyCode As Integer, Shift As Integer)
   Dim Response As Integer
   Dim pRetCode As Integer
   Dim thisRow As Integer
   With F1Book1
        '' In this event we are going to handle the Delete key ourselves.
        '' In the FormActivate event we have set AllowDelete to false, so the
        '' default behavior for the Delete Key is overridden.  First we will
        '' test for the Delete Key, and if we find it, we will make sure that
        '' the end user really intends to delete this record.
        If KeyCode = 46 Then
             Response = MsgBox("Delete Current Record?", vbYesNo, "Formula One")
             If Response = vbYes Then
                  thisRow = .Row
                  '' we call ODBCPrepare with the proper DELETE FROM syntax with the
                  '' information for the current row.  Then we will execute this
                  '' SQLStatement
                  pRetCode = .ODBCPrepareEx("DELETE FROM Memberships WHERE ID = " & Str(.NumberRC(thisRow, 1)))
                  pRetCode = .ODBCExecuteEx(thisRow, thisRow)
                  '' Now we delete the row from the Spreadsheet
                  .DeleteRange thisRow, 1, thisRow, 256, F1ShiftRows
                  '' if we don't set Modified to False, the next time we
                  '' change the selection, the changes to the row will be
                  '' 'saved' to the database
                  .Modified = False
                  '' now we adjust the MaxRow to compensate for the
                  '' deleted row
                  .MaxRow = .MaxRow - 1
                  '' if this was the last record, we will want to move the
                  '' selection to the new last record
                  If .MaxRow + 1 = thisRow Then
                     .Row = thisRow - 1
                  End If
                  SetPattern

             End If
         End If
    End With
End Sub
Private Sub F1Book1_ObjClick(ObjName As String, ByVal ObjID As Long)
Const cmdCol = 4
    Dim text As String
    With F1Book1
    Select Case ObjName
    '' the command button is the only one
    '' with an action
    '' the click will toggle the text
    '' on the button and set the text
    '' underneath
    '' the toggle is based on the cell text due
    '' to the possibility of bad data
    Case "cmdSex"
        text = .ObjText(ObjID)
        Select Case text
        Case "Male"
            .TextRC(.Row, cmdCol) = "Female"
            .ObjText(ObjID) = "Female"
        Case Else
            .TextRC(.Row, cmdCol) = "Male"
            .ObjText(ObjID) = "Male"
        End Select
    Case "cboAncestry"
        '' combo updates cell directly
    Case "chkMemberStatus"
        '' updated through ObjValueChanged event
    End Select
    End With
End Sub
Private Sub F1Book1_ObjValueChanged(ObjName As String, ByVal ObjID As Long)
Const chkCol = 6
    With F1Book1
    Select Case ObjName
    Case "cmdSex"
        '' this is handled in the ObjClick event
    Case "cboAncestry"
        '' combo updates the cell directly
    Case "chkMemberStatus"
        .NumberRC(.Row, chkCol) = .ObjValue(ObjID)
    End Select
    End With
End Sub
Private Sub F1Book1_ODBCExecuteError(ByVal nRow As Long, ByVal nCol As Long, pAction As Integer)
    pAction = F1ODBCErrorAbort
End Sub
Private Sub F1Book1_SelChange()
Dim Unchanged As Boolean
    ''since the SelChange event fires even
    ''when moving to a new cell in the same
    ''row, we will test so that we only
    ''do an update when we move to a new row
    Unchanged = False
    With F1Book1
    If .Modified Then
        If CurrentRow <> .Row Then
            UpdateRecord
        Else
            Unchanged = True
        End If
    End If

    UpdateControlsLocation
    .Modified = False
    If NewRecord And Unchanged Then
        ' we do nothing
    Else
        NewRecord = False
    End If
    CurrentRow = .Row
    End With
End Sub
Private Sub Form_Activate()
   Dim pConnect As New F1ODBCConnect
    Dim pRetCode As Integer
    Dim pQuery As New F1ODBCQuery
    Dim i As Integer
    With F1Book1
            '' we set AllowDelete to False so that we can do our
            '' own Delete routine in the KeyPress event
            .AllowDelete = False
            .ShowSelections = F1On
            .RowMode = True
            '' We define our Connect String and connect to the Database
            pConnect.ConnectStr = "DSN=Smallville Genealogy;DBQ=" & App.Path & "\demo6.mdb;DefaultDir=" & App.Path & ";DriverId=25;FIL=MS"
        On Error GoTo ConnectError
            .ODBCConnectEx pConnect, True
            '' next we prepare to run our Query
            pQuery.QueryStr = "Select * from Memberships"
            pQuery.SetColNames = False
            pQuery.SetColFormats = False
            pQuery.SetColWidths = False
            pQuery.SetMaxRC = True

            .ODBCQueryEx pQuery, 1, 1, False
            '' we'll call a DoEvents to give the Query time to run before updating the control positions
            DoEvents
            UpdateControlsLocation
            '' We set the Modified property to False so that we can trap
            '' when we need to save changes to our database
            .Modified = False
            NewRecord = False
            CurrentRow = F1Book1.Row

            SetPattern
            .SetActiveCell 1, 1
            .ShowActiveCell
    End With
    Exit Sub
ConnectError:
   MsgBox "Make sure that you have named the Database ""Smallville Genealogy"" in the ODBC Setup", vbOKOnly, "ODBC Error"
End Sub
Public Sub UpdateControlsLocation()
    ' for easy changes later
    Const cmdID = 1
    Const cboID = 2
    Const chkID = 3
    Const cmdCol = 4
    Const cboCol = 5
    Const chkCol = 6
    Dim text As String
    Dim thisRow As Integer
    Dim value As Double
    thisRow = F1Book1.Row
     If thisRow = 1 Then
        cmdBack.Enabled = False
    Else
        cmdBack.Enabled = True
    End If
    If thisRow = F1Book1.MaxRow Then
        cmdNext.Enabled = False
    Else
        cmdNext.Enabled = True
    End If

    lblRecordNo.Caption = Str(thisRow) & " of " & Str(F1Book1.MaxRow)
    With F1Book1
        .ObjSetPos cmdID, (cmdCol - 1), (thisRow - 1), cmdCol, thisRow
        .ObjText(cmdID) = F1Book1.TextRC(thisRow, cmdCol)

        .ObjSetPos cboID, (cboCol - 1), (thisRow - 1), cboCol, thisRow + 5
        .ObjSetCell cboID, F1ControlCellValue, thisRow, cboCol
        .ObjValue(cboID) = .NumberRC(thisRow, cboCol)

        .ObjSetPos chkID, (chkCol - 0.97), (thisRow - 0.97), (chkCol - 0.01), (thisRow - 0.03)
        .ObjSetCell chkID, 0, thisRow, chkCol
        .ObjValue(chkID) = .NumberRC(thisRow, chkCol)
    End With
End Sub
Public Sub SetPattern()
Formatting = True
With F1Book1
.Repaint = False
For i = 1 To .MaxRow
        If i Mod 2 = 0 Then
            .SetSelection i, -1, i, -1
            .SetPattern 1, .PaletteEntry(2), .PaletteEntry(2)
            .SetBorder -1, 1, 1, 1, 1, 1, vbBlack, vbBlack, vbBlack, vbBlack, vbBlack
        Else
            .SetSelection i, -1, i, -1
            .SetPattern 1, .PaletteEntry(42), .PaletteEntry(1)
            .SetBorder -1, 1, 1, 1, 1, 1, vbBlack, vbBlack, vbBlack, vbBlack, vbBlack
        End If
    Next i
    .Repaint = True
End With
Formatting = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
    F1Book1.ODBCDisconnect
End Sub
Public Sub UpdateRecord()
Dim pRetCode As Integer
With F1Book1
    If Not Formatting Then
        If NewRecord Then
            pRetCode = .ODBCPrepareEx("INSERT INTO Memberships  VALUES (?, ?, ?, ?, ?, ?, ?)")
            pRetCode = .ODBCBindParameterEx(1, 1, F1CDataLong)
            pRetCode = .ODBCBindParameterEx(2, 2, F1CDataChar)
            pRetCode = .ODBCBindParameterEx(3, 3, F1CDataChar)
            pRetCode = .ODBCBindParameterEx(4, 4, F1CDataChar)
            pRetCode = .ODBCBindParameterEx(5, 5, F1CDataLong)
            pRetCode = .ODBCBindParameterEx(6, 6, F1CDataLong)
            pRetCode = .ODBCBindParameterEx(7, 7, F1CDataDate)
            pRetCode = .ODBCExecuteEx(.MaxRow, .MaxRow)
            SetPattern
        Else
            pRetCode = .ODBCPrepareEx("UPDATE Memberships SET FirstName=?, LastName=?, Sex=?, Ancestry=?, MemberStatus=?, DuesPaidDate=? WHERE ID=?")
            pRetCode = .ODBCBindParameterEx(1, 2, F1CDataChar)
            pRetCode = .ODBCBindParameterEx(2, 3, F1CDataChar)
            pRetCode = .ODBCBindParameterEx(3, 4, F1CDataChar)
            pRetCode = .ODBCBindParameterEx(4, 5, F1CDataLong)
            pRetCode = .ODBCBindParameterEx(5, 6, F1CDataLong)
            pRetCode = .ODBCBindParameterEx(6, 7, F1CDataDate)
            pRetCode = .ODBCBindParameterEx(7, 1, F1CDataLong)
            pRetCode = .ODBCExecuteEx(CurrentRow, CurrentRow)
        End If
    End If
    End With
End Sub